home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xljump.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  4.0 KB  |  186 lines
  1. /* xljump - execution context routines */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern CONTEXT *xlcontext,*xltarget;
  10. extern LVAL xlvalue,xlenv,xlfenv,xldenv;
  11. extern int xlmask;
  12.  
  13. /* forward declarations */
  14. #ifdef ANSI
  15. void findandjump(int mask, char *error);
  16. #else
  17. FORWARD VOID findandjump();
  18. #endif
  19.  
  20. /* xlbegin - beginning of an execution context */
  21. VOID xlbegin(cptr,flags,expr)
  22.   CONTEXT *cptr; int flags; LVAL expr;
  23. {
  24.     cptr->c_flags = flags;
  25.     cptr->c_expr = expr;
  26.     cptr->c_xlstack = xlstack;
  27.     cptr->c_xlenv = xlenv;
  28.     cptr->c_xlfenv = xlfenv;
  29.     cptr->c_xldenv = xldenv;
  30.     cptr->c_xlcontext = xlcontext;
  31.     cptr->c_xlargv = xlargv;
  32.     cptr->c_xlargc = xlargc;
  33.     cptr->c_xlfp = xlfp;
  34.     cptr->c_xlsp = xlsp;
  35.     xlcontext = cptr;
  36. }
  37.  
  38. /* xlend - end of an execution context */
  39. VOID xlend(cptr)
  40.   CONTEXT *cptr;
  41. {
  42.     xlcontext = cptr->c_xlcontext;
  43. }
  44.  
  45. /* xlgo - go to a label */
  46. VOID xlgo(label)
  47.   LVAL label;
  48. {
  49.     CONTEXT *cptr;
  50.     LVAL *argv;
  51.     int argc;
  52.  
  53.     /* find a tagbody context */
  54.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  55.         if (cptr->c_flags & CF_GO) {
  56.             argc = cptr->c_xlargc;
  57.             argv = cptr->c_xlargv;
  58.             while (--argc >= 0)
  59.                 if (*argv++ == label) {
  60.                     cptr->c_xlargc = argc;
  61.                     cptr->c_xlargv = argv;
  62.                     xljump(cptr,CF_GO,NIL);
  63.                 }
  64.         }
  65.     xlfail("no target for GO");
  66. }
  67.  
  68. /* xlreturn - return from a block */
  69. VOID xlreturn(name,val)
  70.   LVAL name,val;
  71. {
  72.     CONTEXT *cptr;
  73.  
  74.     /* find a block context */
  75.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  76.         if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
  77.             xljump(cptr,CF_RETURN,val);
  78.     xlfail("no target for RETURN");
  79. }
  80.  
  81. /* xlthrow - throw to a catch */
  82. VOID xlthrow(tag,val)
  83.   LVAL tag,val;
  84. {
  85.     CONTEXT *cptr;
  86.  
  87.     /* find a catch context */
  88.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  89.         if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  90.             xljump(cptr,CF_THROW,val);
  91.     xlfail("no target for THROW");
  92. }
  93.  
  94. /* xlsignal - signal an error */
  95. VOID xlsignal(emsg,arg)
  96.   char *emsg; LVAL arg;
  97. {
  98.     CONTEXT *cptr;
  99.  
  100.     /* find an error catcher */
  101.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  102.         if (cptr->c_flags & CF_ERROR) {
  103.             if (cptr->c_expr && emsg)
  104.                 xlerrprint("error",NULL,emsg,arg);
  105.             xljump(cptr,CF_ERROR,NIL);
  106.         }
  107. }
  108.  
  109. /* xltoplevel - go back to the top level */
  110. VOID xltoplevel()
  111. {
  112.     stdputstr("[ back to top level ]\n");
  113.     findandjump(CF_TOPLEVEL,"no top level");
  114. }
  115.  
  116. /* xlbrklevel - go back to the previous break level */
  117. VOID xlbrklevel()
  118. {
  119.     findandjump(CF_BRKLEVEL,"no previous break level");
  120. }
  121.  
  122. /* xlcleanup - clean-up after an error */
  123. VOID xlcleanup()
  124. {
  125.     stdputstr("[ back to previous break level ]\n");
  126.     findandjump(CF_CLEANUP,"not in a break loop");
  127. }
  128.  
  129. /* xlcontinue - continue from an error */
  130. VOID xlcontinue()
  131. {
  132.     findandjump(CF_CONTINUE,"not in a break loop");
  133. }
  134.  
  135. #ifdef MSC6
  136. /* no optimization which interferes with setjmp */
  137. #pragma optimize("elg",off)
  138. #endif
  139.  
  140. /* xljump - jump to a saved execution context */
  141. VOID xljump(target,mask,val)
  142.   CONTEXT *target; int mask; LVAL val;
  143. {
  144.     /* unwind the execution stack */
  145.     for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
  146.  
  147.         /* check for an UNWIND-PROTECT */
  148.         if ((xlcontext->c_flags & CF_UNWIND)) {
  149.             xltarget = target;
  150.             xlmask = mask;
  151.             break;
  152.         }
  153.            
  154.     /* restore the state */
  155.     xlstack = xlcontext->c_xlstack;
  156.     xlenv = xlcontext->c_xlenv;
  157.     xlfenv = xlcontext->c_xlfenv;
  158.     xlunbind(xlcontext->c_xldenv);
  159.     xlargv = xlcontext->c_xlargv;
  160.     xlargc = xlcontext->c_xlargc;
  161.     xlfp = xlcontext->c_xlfp;
  162.     xlsp = xlcontext->c_xlsp;
  163.     xlvalue = val;
  164.  
  165.     /* call the handler */
  166.     longjmp(xlcontext->c_jmpbuf,mask);
  167. }
  168.  
  169. #ifdef MSC6
  170. #pragma optimize("",on)
  171. #endif
  172.  
  173. /* findandjump - find a target context frame and jump to it */
  174. LOCAL VOID findandjump(mask,error)
  175.   int mask; char *error;
  176. {
  177.     CONTEXT *cptr;
  178.  
  179.     /* find a block context */
  180.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  181.         if (cptr->c_flags & mask)
  182.             xljump(cptr,mask,NIL);
  183.     xlabort(error);
  184. }
  185.  
  186.